home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 1.iso / HENSA / MATHS / PLPLOT / PLPLOT.ZIP / src / tcl / tclMain.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-06-30  |  9.7 KB  |  363 lines
  1. /* $Id: tclMain.c,v 1.3 1994/06/30 18:52:53 mjl Exp $
  2.  * $Log: tclMain.c,v $
  3.  * Revision 1.3  1994/06/30  18:52:53  mjl
  4.  * Minor change to eliminate a warning.
  5.  *
  6.  * Revision 1.2  1994/06/24  20:40:45  mjl
  7.  * Created function to handle error condition.  Is handled by indirection
  8.  * through a global pointer, so can be replaced.  This call has to bypass
  9.  * the interpreter since it's important that the interp->result string is
  10.  * not modified.
  11.  *
  12.  * Revision 1.1  1994/06/23  22:43:34  mjl
  13.  * Handles nearly all the important setup for extended tclsh's.  Taken from
  14.  * tclMain.c of Tcl 7.3, and modified minimally to support my needs.
  15. */
  16.  
  17. /*
  18.  * Modified version of tclMain.c, from Tcl 7.3.
  19.  * Maurice LeBrun
  20.  * 23-Jun-1994
  21.  *
  22.  * Modifications include:
  23.  * 1. main() changed to pltclMain().
  24.  * 2. tcl_RcFileName changed to pltcl_RcFileName.
  25.  * 3. Changes to work with ANSI C
  26.  * 4. Changes to support user-installable error handler.
  27.  *
  28.  * The original notes follow.
  29.  */
  30.  
  31. /* 
  32.  * main.c --
  33.  *
  34.  *    Main program for Tcl shells and other Tcl-based applications.
  35.  *
  36.  * Copyright (c) 1988-1993 The Regents of the University of California.
  37.  * All rights reserved.
  38.  *
  39.  * Permission is hereby granted, without written agreement and without
  40.  * license or royalty fees, to use, copy, modify, and distribute this
  41.  * software and its documentation for any purpose, provided that the
  42.  * above copyright notice and the following two paragraphs appear in
  43.  * all copies of this software.
  44.  * 
  45.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  46.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  47.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  48.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  49.  *
  50.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  51.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  52.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  53.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  54.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  55.  */
  56.  
  57. #define _POSIX_SOURCE
  58.  
  59. #include <stdio.h>
  60. #include <stdlib.h>
  61. #include <tcl.h>
  62. #include <errno.h>
  63.  
  64. /*
  65.  * Declarations for various library procedures and variables (don't want
  66.  * to include tclUnix.h here, because people might copy this file out of
  67.  * the Tcl source directory to make their own modified versions).
  68.  */
  69.  
  70. extern int        errno;
  71. extern void        exit _ANSI_ARGS_((int status));
  72. extern int        isatty _ANSI_ARGS_((int fd));
  73. extern char *        strcpy _ANSI_ARGS_((char *dst, CONST char *src));
  74.  
  75. static Tcl_Interp *interp;    /* Interpreter for application. */
  76. static Tcl_DString command;    /* Used to buffer incomplete commands being
  77.                  * read from stdin. */
  78. char *pltcl_RcFileName = NULL;    /* Name of a user-specific startup script
  79.                  * to source if the application is being run
  80.                  * interactively (e.g. "~/.tclshrc").  Set
  81.                  * by Tcl_AppInit.  NULL means don't source
  82.                  * anything ever. */
  83. #ifdef TCL_MEM_DEBUG
  84. static char dumpFile[100];    /* Records where to dump memory allocation
  85.                  * information. */
  86. static int quitFlag = 0;    /* 1 means the "checkmem" command was
  87.                  * invoked, so the application should quit
  88.                  * and dump memory allocation information. */
  89. #endif
  90.  
  91. /*
  92.  * Forward references for procedures defined later in this file:
  93.  */
  94.  
  95. static int        CheckmemCmd _ANSI_ARGS_((ClientData clientData,
  96.                 Tcl_Interp *interp, int argc, char *argv[]));
  97.  
  98. static void
  99. ErrorHandler _ANSI_ARGS_((Tcl_Interp *interp, int code, int tty));
  100.  
  101. /* This is globally visible and can be replaced */
  102.  
  103. void (*tclErrorHandler)
  104.     _ANSI_ARGS_((Tcl_Interp *interp, int code, int tty)) = ErrorHandler;
  105.  
  106. /*
  107.  *----------------------------------------------------------------------
  108.  *
  109.  * main --
  110.  *
  111.  *    This is the main program for a Tcl-based shell that reads
  112.  *    Tcl commands from standard input.
  113.  *
  114.  * Results:
  115.  *    None.
  116.  *
  117.  * Side effects:
  118.  *    Can be almost arbitrary, depending on what the Tcl commands do.
  119.  *
  120.  *----------------------------------------------------------------------
  121.  */
  122.  
  123. int
  124. pltclMain(int argc, char **argv)
  125. {
  126.     char buffer[1000], *cmd, *args, *fileName;
  127.     int code, gotPartial, tty;
  128.     int exitCode = 0;
  129.  
  130.     interp = Tcl_CreateInterp();
  131. #ifdef TCL_MEM_DEBUG
  132.     Tcl_InitMemory(interp);
  133.     Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
  134.         (Tcl_CmdDeleteProc *) NULL);
  135. #endif
  136.  
  137.     /*
  138.      * Make command-line arguments available in the Tcl variables "argc"
  139.      * and "argv".  If the first argument doesn't start with a "-" then
  140.      * strip it off and use it as the name of a script file to process.
  141.      */
  142.  
  143.     fileName = NULL;
  144.     if ((argc > 1) && (argv[1][0] != '-')) {
  145.     fileName = argv[1];
  146.     argc--;
  147.     argv++;
  148.     }
  149.     args = Tcl_Merge(argc-1, argv+1);
  150.     Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
  151.     ckfree(args);
  152.     sprintf(buffer, "%d", argc-1);
  153.     Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
  154.     Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
  155.         TCL_GLOBAL_ONLY);
  156.  
  157.     /*
  158.      * Set the "tcl_interactive" variable.
  159.      */
  160.  
  161.     tty = isatty(0);
  162.     Tcl_SetVar(interp, "tcl_interactive",
  163.         ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
  164.  
  165.     /*
  166.      * Invoke application-specific initialization.
  167.      */
  168.  
  169.     if (Tcl_AppInit(interp) != TCL_OK) {
  170.     fprintf(stderr, "Tcl_AppInit failed: %s\n", interp->result);
  171.     }
  172.  
  173.     /*
  174.      * If a script file was specified then just source that file
  175.      * and quit.
  176.      */
  177.  
  178.     if (fileName != NULL) {
  179.     code = Tcl_EvalFile(interp, fileName);
  180.     if (code != TCL_OK) {
  181.         fprintf(stderr, "%s\n", interp->result);
  182.         exitCode = 1;
  183.     }
  184.     goto done;
  185.     }
  186.  
  187.     /*
  188.      * We're running interactively.  Source a user-specific startup
  189.      * file if Tcl_AppInit specified one and if the file exists.
  190.      */
  191.  
  192.     if (pltcl_RcFileName != NULL) {
  193.     Tcl_DString buffer;
  194.     char *fullName;
  195.     FILE *f;
  196.  
  197.     fullName = Tcl_TildeSubst(interp, pltcl_RcFileName, &buffer);
  198.     if (fullName == NULL) {
  199.         fprintf(stderr, "%s\n", interp->result);
  200.     } else {
  201.         f = fopen(fullName, "r");
  202.         if (f != NULL) {
  203.         code = Tcl_EvalFile(interp, fullName);
  204.         if (code != TCL_OK) {
  205.             fprintf(stderr, "%s\n", interp->result);
  206.         }
  207.         fclose(f);
  208.         }
  209.     }
  210.     Tcl_DStringFree(&buffer);
  211.     }
  212.  
  213.     /*
  214.      * Process commands from stdin until there's an end-of-file.
  215.      */
  216.  
  217.     gotPartial = 0;
  218.     Tcl_DStringInit(&command);
  219.     while (1) {
  220.     clearerr(stdin);
  221.     if (tty) {
  222.         char *promptCmd;
  223.  
  224.         promptCmd = Tcl_GetVar(interp,
  225.         gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
  226.         if (promptCmd == NULL) {
  227.         defaultPrompt:
  228.         if (!gotPartial) {
  229.             fputs("% ", stdout);
  230.         }
  231.         } else {
  232.         code = Tcl_Eval(interp, promptCmd);
  233.         if (code != TCL_OK) {
  234.             fprintf(stderr, "%s\n", interp->result);
  235.             Tcl_AddErrorInfo(interp,
  236.                 "\n    (script that generates prompt)");
  237.             goto defaultPrompt;
  238.         }
  239.         }
  240.         fflush(stdout);
  241.     }
  242.     if (fgets(buffer, 1000, stdin) == NULL) {
  243.         if (ferror(stdin)) {
  244.         if (errno == EINTR) {
  245.             if (tcl_AsyncReady) {
  246.             (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
  247.             }
  248.             clearerr(stdin);
  249.         } else {
  250.             goto done;
  251.         }
  252.         } else {
  253.         if (!gotPartial) {
  254.             goto done;
  255.         }
  256.         }
  257.         buffer[0] = 0;
  258.     }
  259.     cmd = Tcl_DStringAppend(&command, buffer, -1);
  260.     if ((buffer[0] != 0) && !Tcl_CommandComplete(cmd)) {
  261.         gotPartial = 1;
  262.         continue;
  263.     }
  264.  
  265.     gotPartial = 0;
  266.     code = Tcl_RecordAndEval(interp, cmd, 0);
  267.     Tcl_DStringFree(&command);
  268.  
  269.     if ((code != TCL_OK) || (tty && (*interp->result != 0)))
  270.         (*tclErrorHandler)(interp, code, tty);
  271.  
  272. #ifdef TCL_MEM_DEBUG
  273.     if (quitFlag) {
  274.         Tcl_DeleteInterp(interp);
  275.         Tcl_DumpActiveMemory(dumpFile);
  276.         exit(0);
  277.     }
  278. #endif
  279.     }
  280.  
  281.     /*
  282.      * Rather than calling exit, invoke the "exit" command so that
  283.      * users can replace "exit" with some other command to do additional
  284.      * cleanup on exit.  The Tcl_Eval call should never return.
  285.      */
  286.  
  287.     done:
  288.     sprintf(buffer, "exit %d", exitCode);
  289.     Tcl_Eval(interp, buffer);
  290.     return 1;
  291. }
  292.  
  293. /*
  294.  *----------------------------------------------------------------------
  295.  *
  296.  * ErrorHandler --
  297.  *
  298.  *    Handles error conditions while parsing.  Can be replaced by the
  299.  *    caller, but only via the C API, as otherwise interp->result will
  300.  *    get trashed by the call.
  301.  *
  302.  * Results:
  303.  *    None.
  304.  *
  305.  * Side effects:
  306.  *    Error info is printed to stdout or stderr.
  307.  *
  308.  *----------------------------------------------------------------------
  309.  */
  310.     /* ARGSUSED */
  311. static void
  312. ErrorHandler(interp, code, tty)
  313.     Tcl_Interp *interp;            /* Interpreter for evaluation. */
  314.     int code;                /* Error code returned by last cmd. */
  315.     int tty;                /* Set if connected to a tty. */
  316. {
  317.     if (code != TCL_OK) {
  318.     fprintf(stderr, "%s\n", interp->result);
  319.  
  320.     } else if (tty && (*interp->result != 0)) {
  321.     printf("%s\n", interp->result);
  322.     }
  323. }
  324.  
  325. /*
  326.  *----------------------------------------------------------------------
  327.  *
  328.  * CheckmemCmd --
  329.  *
  330.  *    This is the command procedure for the "checkmem" command, which
  331.  *    causes the application to exit after printing information about
  332.  *    memory usage to the file passed to this command as its first
  333.  *    argument.
  334.  *
  335.  * Results:
  336.  *    Returns a standard Tcl completion code.
  337.  *
  338.  * Side effects:
  339.  *    None.
  340.  *
  341.  *----------------------------------------------------------------------
  342.  */
  343. #ifdef TCL_MEM_DEBUG
  344.  
  345.     /* ARGSUSED */
  346. static int
  347. CheckmemCmd(clientData, interp, argc, argv)
  348.     ClientData clientData;        /* Not used. */
  349.     Tcl_Interp *interp;            /* Interpreter for evaluation. */
  350.     int argc;                /* Number of arguments. */
  351.     char *argv[];            /* String values of arguments. */
  352. {
  353.     if (argc != 2) {
  354.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  355.         " fileName\"", (char *) NULL);
  356.     return TCL_ERROR;
  357.     }
  358.     strcpy(dumpFile, argv[1]);
  359.     quitFlag = 1;
  360.     return TCL_OK;
  361. }
  362. #endif
  363.